COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A Metering System for MacLisp
C00027 00003	 Here's a typical file:
C00031 ENDMK
C⊗;
;;; A Metering System for MacLisp

(declare (special meter:meters meter:max meter:comments meter:meterp
		  meter:max-max meter:maxf meter:factor meter:array-name
		  meter:array-size meter:start-time meter:end-time meter:inc-only
		  meter:all-comments meter:local-max meter:real-runtime
		  meter:comment-name meter:fun-names meter:name meter:count-only
		  meter:inc-onlys
		  meter:count-array-name)
	 (mapex t)
	 (*lexpr %match)
	 (flonum meter:real-runtime)
	 (fixnum meter:max-max meter:max)) 

(eval-when (compile eval)
	   (setq meter:meters () meter:fun-names ()
		 meter:all-comments () meter:comments ()))

(eval-when (load eval)
	   (cond ((not (boundp 'meter:count-only))
		  (setq meter:count-only ()))))

(eval-when (load)
	   (cond ((boundp 'meter:meters))
		 (t (setq meter:meters ()))))

;;; (meter (defun foo ... (m "Baz"))...)
;;; (m "Foo") 	adds 1 to the "Foo" counter
;;; (m "Foo" 3) adds 3 to the "Foo" counter
;;; (m "Foo" 3 (foo a b c)) adds 3 to the "Foo" counter and counts the runtime
;;; (mn "Foo" foo) adds 1 to the foo counter
;;; (mn "Foo" foo 3) adds 3 to the foo counter
;;; (mn "Foo" foo 3 (foo a b c)) adds 3 to the foo counter and counts the runtime
;;;	in all cases the counts are listed as "Foo"
;;;  the indexed ones (mn ...) are so that PUSH can be counted as a CONS.

;;;						      the index for this entry
;;;							 |
;;;							 | number to increment by
;;; (meter-funs						 ↓   ↓
;;;  ((zerop "Zerop")(1- "1-") (* "Times")(PUSH "CONSs" CONS 2))
;;; 		  (defun fact (n)			 ↑   ↑ 
;;; 			 (cond ((zerop n) 1)		optionals
;;; 			       (t (* n (fact (1- n)))))))

;;; METER:COUNT-ONLY, defaultly (), is T if you want to only count the
;;; number of forms evaluated,  skipping the runtime info.

;;; THE FILE MUST LOOK LIKE:
;;; (FASLOAD METER FAS DSK (TIM LSP))
;;; (METER:METER <name> 
;;;   <contents of your file>)

(defun meter:make-name (symbol)
       (implode (append (explode symbol)
			'(-)
			(explode meter:name))))

;;; F is a form. L is an alist
(defun meter:assoc-1 (f l avoid)
       (do ((l l (cdr l)))
	   ((null l) ())
	   (cond ((and (equal (car f) (caar l))
		       (not (memq (car l) avoid)))
		  (return (car l)))
		 ((atom (caar l)))
		 ((and (%match (caar l) f)
		       (not (memq (car l) avoid)))
		  (return (car l))))))

;;; F is a form. L is an alist
(defmacro meter:assoc-2 (f l)
	  `(let ((f ,f)(l ,l))
		(do ((l l (cdr l)))
		    ((null l) ())
		    (cond ((equal f (caar l))
			   (return (car l)))
			  ((atom (caar l)))
			  ((%match (caar l) f)
			   (return (car l)))))))

(defmacro meter:meter (name . forms)
	  (setq meter:name name)
	  (setq meter:maxf (meter:make-name 'meter:maxf)
		meter:array-name (meter:make-name 'meter:array-name)
		meter:count-array-name (meter:make-name 'meter:count-array-name)
		meter:array-size (meter:make-name 'meter:array-size)
		meter:factor (meter:make-name 'meter:factor)
		meter:comment-name (meter:make-name 'meter:comment-name)
		meter:inc-onlys ()
		meter:max-max 0)
	  (set  meter:comment-name
		(implode (append '(m e t e r :)
				 (explode name)
				 '(- c o m m e n t))) )
	  (set meter:array-name
	       (implode (append '(m e t e r :)
				(explode name) 
				'(- a r r a y))))
	  (cond (meter:count-only
		 (set meter:count-array-name
		      (implode (append '(m e t e r :)
				       (explode name) 
				       '(- c o u n t - a r r a y))))))
	  (set meter:maxf -1)
	  (setq meter:start-time (meter:make-name 'meter:start-time)
	        meter:end-time (meter:make-name 'meter:end-time)
		meter:inc-only (meter:make-name 'meter:inc-only))
	  (setq meter:fun-names ()
		meter:all-comments ()
		meter:comments ())
	  (let ((forms (mapcar #'meter:pass2 
			       (prog1
				(mapcan #'meter:pass1 forms)
				(set meter:factor (1+ meter:max-max))))))
	       (set meter:array-size (* (1+ (symeval meter:maxf))
					(1+ meter:max-max)))
	       `(progn 'compile 
		       (declare (array* (notype ,(symeval meter:comment-name)
						2)
					(fixnum ,(symeval meter:array-name)
						1) 
					,@(cond (meter:count-only
						 `((fixnum ,(symeval 
							     meter:count-array-name)
							   1)))))
				(fixnum ,meter:factor 
					,meter:array-size)
				(special ,meter:factor 
					 ,meter:array-size 
					 ,meter:inc-only
					 ,meter:array-name
					 ,meter:count-array-name
					 ,meter:maxf 
					 ,meter:comment-name
					 meter:real-runtime)
				(*expr ,(meter:make-name 'meter:start-time)
				       ,(meter:make-name 'meter:inc-only)
				       ,(meter:make-name 'meter:end-time) ))
		       (array ,(symeval meter:comment-name) t 
			      ,(+ 2 (symeval meter:maxf))
			      ,(+ 2 meter:max-max))
		       (setq ,(meter:make-name 'meter:array-size)
			     ,(* (1+ (symeval meter:maxf))
				 (1+ meter:max-max)))
		       (setq ,meter:inc-only (quote ,meter:inc-onlys))
		       (array ,(symeval meter:array-name)
			      fixnum ,(1+ (symeval meter:maxf)))
		       ,@(cond (meter:count-only
				`((array ,(symeval meter:count-array-name)
					 fixnum 
					 ,(* (1+ (symeval meter:maxf))
					     (1+ meter:max-max))))))
		       (do ((i ,(symeval meter:maxf) (1- i)) 
			    (a (quote ,meter:fun-names) (cdr a))
			    (b (quote ,meter:all-comments) (cdr b)))
			   ((< i 0) ())
			   (store (,(symeval meter:comment-name) i 0) 
				  (car a))
			   (store (,(symeval meter:array-name) i)
				  (cadr (meter:assoc-2 (car a) ',meter:meters)))
			   ,@(cond (meter:count-only
				    `((store (,(symeval meter:count-array-name) i)
					     0))))
			   (do ((j 1 (1+ j))
				(c (reverse (car b)) (cdr c)))
			       ((null c) ())
			       (store (,(symeval meter:comment-name) i j) 
				      (cadr (car c))))) 
		       (setq ,meter:factor
			     ,(1+ meter:max-max))
		       ,@(cond (meter:count-only
				`((setq ,meter:count-array-name
					(quote ,(symeval meter:count-array-name))))))
		       (setq ,meter:array-name
			     (quote ,(symeval meter:array-name))
			     ,meter:maxf ,(symeval meter:maxf)
			     ,meter:comment-name 
			     (quote ,(symeval meter:comment-name)))
		       ,@forms
		       (include "metaux.lsp[tim,lsp]"))))

(defun meter:pass1 (form)
       (cond ((atom form) `(,form))
	     (t (caseq (car form)
		       (meter-funs
			(cond ((and (boundp 'meter:meterp)
				    (not meter:meterp))
			       (cdr form))
			      (t
			       (let ((funs (cadr form)))
				    (meter:pass1-a
				     (mapcar 
				      #'(lambda (f) 
						(cond ((memq (car f) '(defun defmacro))
						       `(,(car f) ,(cadr f) ,(caddr f)
								  .,(meter:meter-funs funs 
										      () (cdddr f))))
						      (t f)))
				      (cddr form)))))))
		       (meter
			(cond ((and (boundp 'meter:meterp)
				    (not meter:meterp))
			       (cdr form))
			      (t
			       (meter:pass1-a (cdr form)))))
		       (t `(,form)))))) 

(defun meter:pass1-a (funs)
       (let ((name (cadr (car funs))))
	    (set meter:maxf (1+ (symeval meter:maxf)))
	    (setq meter:max -1)
	    (prog1
	     (mapcar #'(lambda (f)
			       (cond ((memq (car f) '(defun defmacro))
				      `(defun
					,(cadr f)
					,(caddr f)
					.,(meter:process 
					   meter:array-name 
					   (cdddr f))))
				     (t f)))
		     funs)
	     (push name meter:fun-names)
	     (push 
	      meter:comments
	      meter:all-comments)
	     (setq meter:comments ())
	     (let ((entry (assoc name meter:meters)))
		  (cond (entry (rplaca (cdr entry) meter:max))
			(t 
			 (push 
			  `(,name ,meter:max)
			  meter:meters))))
	     (setq meter:max-max (max meter:max-max meter:max)))))

(defun meter:pass2 (fun)
 (meter:pass2-a fun) fun))

(defun meter:pass2-a (fun)
       (cond ((null fun) ())
	     ((atom fun) ())
	     ((numberp fun) ())
	     ((eq (car fun) meter:end-time)
	      (rplacd fun `(,(+ (* (symeval meter:factor) (cadr fun))
				(caddr fun)) ,(cadddr fun))))
	     ((eq (car fun) meter:inc-only)
	      (let ((x 
		     (+ (* (symeval meter:factor) (cadr fun))
				(caddr fun))))
		   (push x meter:inc-onlys)
		   (rplacd fun `(,x ,(cadddr fun)))))
	     ((eq (car fun) 'meter:inc)
	      (rplacd (cdr fun) `(,(+ (* (symeval meter:factor) (caddr fun))
				      (cadddr fun)) ,(cadddr (cdr fun)))))

	     (t (mapc #'meter:pass2-a fun))))

(defmacro meter:expr-p (f)
	  `(do ((l (plist (car ,f)) (cddr l)))
	       ((null l) t)
	       (cond ((memq (car l) '(expr *expr subr lsubr)) (return t))
		     ((memq (car l) '(fexpr *fexpr fsubr macro)) (return ())))))

(defmacro meter:special-case-p (f)
	  `(get (car ,f) 'meter:expand-code))

(defun meter:bindable-form (l avoid form)
       (cond ((atom form) ())
	     ((numberp form) ())
	     ((meter:expr-p form)
	      (let ((args ()))
		   `(,(mapcan #'(lambda (x)
					(cond ((or (atom x) 
						   (null x)
						   (numberp x)
						   (eq (car x) 'quote))
					       (push x args) ())
					      (t (let ((x (gensym)))
						      (push x args)
						      (ncons x)))))
			      (cdr form)) 
		     (,(car form) . ,(reverse args))
		     ,(mapcan #'(lambda (x)
					(cond ((or (atom x) 
						   (null x)
						   (numberp x)
						   (eq (car x) 'quote))
					       ())
					      (t `(,x))))
			      (cdr form)))))
	     (t (let ((handler (meter:special-case-p form)))
		     (cond (handler (funcall handler form l avoid)))))))

(defun meter:meter-funs (l avoid f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((memq (car f) '(mn m))
	      (caseq (length f)
		     ((1 2 3 4) f)
		     (5 `(,(car f) ,(cadr f) ,(caddr f) ,(cadddr f)
				   ,(meter:meter-funs l avoid (cadddr (cdr f)))))
		     (t f)))
	     (t (let ((entry (meter:assoc-1 f l avoid)))
		     (cond (entry
			    (let ((q (meter:bindable-form l avoid f)))
				 (cond ((and q (car q))
					`((lambda ,(car q)
						  (mn 
						   ,(cadr entry) 
						   ,(or (caddr entry)
							(car entry))
						   ,(or (cadddr entry) 1)
						   ,(cadr q)))
					  . ,(mapcar 
					      #'(lambda (x)
							(meter:meter-funs
							 l avoid x))
					      (caddr q))))
				       (t
					`(mn ,(cadr entry) ,(or (caddr entry)
								(car entry))
					     ,(or (cadddr entry) 1)
					     ,(meter:meter-funs 
					       l `(,entry . ,avoid) f))))))
			   ((eq (car f) 'store)
			    `(store ,(cadr f) ,(meter:meter-funs l avoid (caddr f))))
			   ((eq (car f) 'quote) f)
			   (t (mapcar #'(lambda (f)
					 (meter:meter-funs l avoid f))
				      f)))))))

(defun meter:process (a f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'm)
	      (let* ((form ())
		     (inc (cond ((null (cddr f)) 1)
				((null (cdddr f))
				 (caddr f))
				(t 
				 (setq form (cadddr f))
				 (caddr f)))))
		    (setq meter:max (1+ meter:max))
		    (push `(() ,(cadr f)
			       ,(symeval meter:maxf) ,meter:max
			       ,inc)
			  meter:comments)
		    (cond (form
			   (cond (meter:count-only
				  `(progn (meter:inc 
					   ,(symeval meter:count-array-name)
					   ,(symeval meter:maxf)
					   ,meter:max ,inc)  
					  ,(meter:process a form)))
				 (t `(prog2 (,meter:start-time)
					    ,(meter:process a form)
					    (,meter:end-time
					     ,(symeval meter:maxf)
					     ,meter:max ,inc))) ))
			  (t (cond (meter:count-only
				    `(meter:inc ,(symeval meter:count-array-name)
						,(symeval meter:maxf)
						,meter:max ,inc))
				   (t `(,meter:inc-only ,(symeval meter:maxf)
							,meter:max ,inc)))))))
	     ((eq (car f) 'mn)
	      (let* ((index (caddr f))
		     (entry (assoc index meter:comments))
		     (form ())
		     (inc (cond ((null (cdddr f)) 1)
				((null (cdr (cdddr f)))
				 (caddr (cdr f)))
				(t 
				 (setq form (cadddr (cdr f)))
				 (caddr (cdr f)))))
     		     (args
		      (cond (entry 
			     (cddr entry))
			    (t (setq meter:max (1+ meter:max))
			       (push `(,index ,(cadr f)
					      ,(symeval meter:maxf)
					      ,meter:max ,inc)
				     meter:comments)
			       `(,(symeval meter:maxf) ,meter:max ,inc)))))
		    (cond (form
			   (cond (meter:count-only
				  `(progn (meter:inc ,(symeval meter:count-array-name)
						     .,args)
					  ,(meter:process a form)))
				 (t `(prog2 (,meter:start-time) ,(meter:process a form)
					    (,meter:end-time .,args)))))
			  (t 
			   (cond (meter:count-only
				  `(meter:inc ,(symeval meter:count-array-name) .,args))
				 (t `(,meter:inc-only .,args)))))))
	     ((eq (car f) 'store)
	      `(store ,(cadr f) ,(meter:process a (caddr f))))
	     ((eq (car f) 'quote) f)
	     ((eq (car f) 'do)
	      `(do ,(mapcar #'(lambda (x)
				      `(,(car x)
					. ,(mapcar #'(lambda (f)
							     (meter:process a f))
						   (cdr x))))
			    (cadr f))
		   ,(mapcar #'(lambda (x) (meter:process a x)) (caddr f))
		   . ,(mapcar #'(lambda (x) (meter:process a x)) (cdddr f))))  
	     ((eq (car f) 'let)
	      `(let ,(mapcar #'(lambda (x)
				       (cond ((atom x) x)
					     (t `(,(car x)
						  ,(meter:process a (cadr x))))))
			     (cadr f))
		    . ,(mapcar#'(lambda (q)
					(meter:process a q))
				(cddr f))))
	     ((memq (car f) '(lambda prog))
	      `(,(car f) ,(cadr f)
		       . ,(mapcar#'(lambda (q)
					   (meter:process a q))
				   (cddr f))))
	     (t (mapcar #'(lambda (f) (meter:process a f))
			f))))

(defun meter:unprocess (f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'quote) f)
	     ((eq (car f) 'do)
	      `(do ,(mapcar #'(lambda (x)
				      `(,(car x)
					. ,(mapcar #'(lambda (f)
							     (meter:unprocess f))
						   (cdr x))))
			    (cadr f))
		   ,(mapcar #'(lambda (x) (meter:unprocess x)) (caddr f))
		   . ,(mapcar #'(lambda (x) (meter:unprocess x)) (cdddr f))))  
	     ((eq (car f) 'let)
	      `(let ,(mapcar #'(lambda (x)
				       (cond ((atom x) x)
					     (t `(,(car x)
						  ,(meter:unprocess (cadr x))))))
			     (cadr f))
		    . ,(mapcar#'(lambda (q)
					(meter:unprocess q))
				(cddr f))))
	     ((memq (car f) '(lambda prog))
	      `(,(car f) ,(cadr f)
		       . ,(mapcar#'(lambda (q)
					   (meter:unprocess q))
				   (cddr f))))
	     ((atom (car f))
	      `(,(car f) . ,(meter:unprocess (cdr f))))
	     ((eq (caar f) 'm)
	      (let ((form 
		      (cond ((null (cddr (car f))) ())
			    ((null (cdddr (car f)))
				 ())
			    (t 
			     (cadddr (car f)))))) 
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     ((eq (caar f) 'mn)
	      (let ((form
		     (cond ((null (cdddr (car f))) ())
			   ((null (cdr (cdddr (car f))))
			    ())
			   (t 
			    (cadddr (cdr (car f)))))))
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     (t `(,(meter:unprocess (car f))
		  . ,(meter:unprocess (cdr f))))))

(defmacro meter:inc (name index incr)
	  `(store (,name ,index)
		  (+ (,name ,index) ,incr)))

(defun (push meter:expand-code) (form l avoid)
       (let ((q (gensym)))
	    `((,q) (push ,q ,(caddr form)) 
		   (,(meter:meter-funs l avoid (cadr form))))))

(defun (setq meter:expand-code) (form l avoid)
       (do ((form (cdr form) (cddr form))
	    (sym ())
	    (vals ())
	    (vars ())
	    (args ()))
	   ((null form)
	    `(,(reverse vars) (setq .,(reverse args)) ,(reverse vals)))
	   (push (car form) args)
	   (cond ((not (atom (cadr form)))
		  (push (meter:meter-funs l avoid (cadr form)) vals)
		  (setq sym (gensym))
		  (push sym args)
		  (push sym vars))
		 (t (push (cadr form) args)))))
;;; Here's a typical file:

;(declare 
; (fasload meter fas))
;
;(meter:meter baz
;	     (meter-funs ((+ "+'s")(= "='s")(foo "Calls to FOO"))
;			 (defun baz (n)
;				(do ((n n (1- n))
;				     (a 0))
;				    ((= n 0) a)
;				    (foo n)
;				    (setq a (+ a n)))) )
; 	     (meter-funs ((+ "+'s")(= "='s"))
;			 (defun foo (n)
;				(do ((n n (1- n))
;				     (a 0))
;				    ((= n 0) a)
;				    (setq a (+ a n))))))